unit heAutomata;

{$mode objfpc}{$H+}

// Copyright 2010, bflm. All rights reserved.
// Use of this source code is governed by a BSD-style
// license that can be found in the LICENSE file.

interface

uses
  heContnrs;

type

  TheNFAState = class;

  { TheNFAEdge }

  TheNFAEdge = class
  private
    FPriority: Integer;
    FTarget: TheNFAState;
    FValue: Integer;
    function GetIsDot: Boolean;
    function GetIsEpsilon: Boolean;
  public
    property Priority: Integer read FPriority;
    property IsDot: Boolean read GetIsDot; // edge value semantics = '.'
    property IsEpsilon: Boolean read GetIsEpsilon; // unlabeled edge
    property Target: TheNFAState read FTarget write FTarget;
    property Value: Integer read FValue;
  end;

  { TheNFAState }

  _TheNFAState = specialize TheObjectVector<TheNFAEdge>;
  TheNFAState = class(_TheNFAState)
  private
    FID: Cardinal;
  public
    property ID: Cardinal read FID;
  end;

  { TheNFA }

  _TheNFA = specialize TheObjectVector<TheNFAState>;
  TheNFA = class(_TheNFA)
  private
    FAcceptState: TheNFAState;
    FStartState: TheNFAState;
  public
    function FullMatch(const S: String): Boolean; virtual; abstract;
    function PartialMatch(const S: String): Boolean; virtual; abstract;
    property AcceptState: TheNFAState read FAcceptState;
    property StartState: TheNFAState read FStartState;
  end;

function REParser(const RE: String): TheNFA;

implementation

uses
  StrUtils,
  SysUtils;

const
  ALL_CHARS = [#0..#$FF];
  NON_NULL_CHARS = ALL_CHARS - [#0];
  DOT_CHARS = NON_NULL_CHARS - [#10];

type
  TCharSet = set of Char;

  TSpecialEdgeValue = (
    sevEpsilon = Low(Integer),
    sevDot
  );

  { TSparseSet }

  TSparseSet = class
  private
    FCount: Cardinal;
    FDense: PCardinal;
    FMaxCardinality: Integer;
    FSparse: PCardinal;
    function GetItems(const Index: Cardinal): Cardinal; inline;
  public
    constructor Create(const AMaxCardinality: Integer);
    destructor Destroy; override;
    function Has(const Member: Cardinal): Boolean; inline;
    function Include(const Member: Cardinal): Boolean; inline;
    procedure Clear; inline;
    property Count: Cardinal read FCount;
    property Items[const Index: Cardinal]: Cardinal read GetItems; default;
    property MaxCardinality: Integer read FMaxCardinality;
  end;

  TState = class;

  { TEdge }

  TEdge = class(TheNFAEdge)
  public
    constructor Create(const ATarget: TState; const AValue: Integer = Ord(sevEpsilon); const APriority: Integer = 0);
  end;

  { TState }

  TState = class(TheNFAState)
  public
    function Closure(Dest: TSparseSet; const AcceptStateID: Cardinal): Boolean;
    function NewEdge(const Target: TState; const Value: Integer; const Priority: Integer = 0): TEdge;
    function NewEpsilonEdge(const Target: TState; const Priority: Integer = 0): TEdge;
    procedure Closure(Dest: TSparseSet);
  end;

  TNFAComponent = record
    Enter: TState;
    Leave: TState;
  end;

  { TNFA }

  TNFA = class(TheNFA)
  private
    FDotStarStartState: TState;
    function Alternative(const Component: TNFAComponent; const Value: Integer; const Priority: Integer = 0): TNFAComponent;
    function NewComponent(const Component: TNFAComponent): TNFAComponent;
    function NewComponent(const Value: Integer; const Priority: Integer = 0): TNFAComponent;
    function NewComponent: TNFAComponent;
    function NewState: TState;
    function OneOrMore(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
    function ZeroOrMore(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
    function ZeroOrOne(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
    procedure Alternative(const Component, Alt: TNFAComponent; const Priority: Integer = 0);
    procedure AssignStateIDs;
  public
    constructor Create(const RE: String);
    function FullMatch(const S: String): Boolean; override;
    function PartialMatch(const S: String): Boolean; override;
    property DotStarStartState: TState read FDotStarStartState;
  end;

function REParser(const RE: String): TheNFA;
begin
  Result := TNFA.Create(RE);
end;

{ TSparseSet }

function TSparseSet.GetItems(const Index: Cardinal): Cardinal;
begin
  Assert(Index < Count);
  Result := FDense[Index];
end;

constructor TSparseSet.Create(const AMaxCardinality: Integer);
begin
  inherited Create;
  FMaxCardinality := AMaxCardinality;
  GetMem(FDense, MaxCardinality * SizeOf(Cardinal));
  GetMem(FSparse, MaxCardinality * SizeOf(Cardinal));
end;

destructor TSparseSet.Destroy;
begin
  FreeMem(FDense);
  FreeMem(FSparse);
  inherited Destroy;
end;

function TSparseSet.Has(const Member: Cardinal): Boolean;
var I: Integer;
begin
  for I := 0 to Count - 1 do
    if FDense[I] = Member then
      Exit(True);
  Result := False;
end;

function TSparseSet.Include(const Member: Cardinal): Boolean;
var Dense: Cardinal;
begin
  Assert(Member < MaxCardinality);
  Dense := FSparse[Member];
  if (Dense < Count) and (FDense[Dense] = Member) then
    Exit(True);
  FDense[FCount] := Member;
  FSparse[Member] := FCount;
  Inc(FCount);
  Result := False;
end;

procedure TSparseSet.Clear;
begin
  FCount := 0;
end;

{ TheNFAEdge }

function TheNFAEdge.GetIsDot: Boolean;
begin
  Result := Value = Ord(sevDot);
end;

function TheNFAEdge.GetIsEpsilon: Boolean;
begin
  Result := Value = Ord(sevEpsilon);
end;

{ TEdge }

constructor TEdge.Create(const ATarget: TState; const AValue: Integer; const APriority: Integer);
begin
  inherited Create;
  FTarget := ATarget;
  FValue := AValue;
  FPriority := APriority;
end;

{ TState }

procedure TState.Closure(Dest: TSparseSet);
var
  I: Integer;
  Edge: TheNFAEdge;
begin
  if not Dest.Include(ID) then
    for I := 0 to Count - 1 do begin
      Edge := Self[I];
      if Edge.Value = Ord(sevEpsilon) then // epsilon edge
        TState(Edge.Target).Closure(Dest);
    end;
end;

function TState.Closure(Dest: TSparseSet; const AcceptStateID: Cardinal): Boolean;
var
  I: Integer;
  Edge: TheNFAEdge;
begin
  if ID = AcceptStateID then
    Exit(True);
  if not Dest.Include(ID) then
    for I := 0 to Count - 1 do begin
      Edge := Self[I];
      if Edge.Value = Ord(sevEpsilon) then // epsilon edge
        if TState(Edge.Target).Closure(Dest, AcceptStateID) then
          Exit(True);
    end;
  Result := False;
end;

function TState.NewEdge(const Target: TState; const Value: Integer; const Priority: Integer): TEdge;
begin
  Result := TEdge(Push(TEdge.Create(Target, Value, Priority)));
end;

function TState.NewEpsilonEdge(const Target: TState; const Priority: Integer): TEdge;
begin
  Result := TEdge(Push(TEdge.Create(Target, Ord(sevEpsilon), Priority)));
end;

{ TNFA }

function TNFA.Alternative(const Component: TNFAComponent; const Value: Integer; const Priority: Integer): TNFAComponent;
begin
  Component.Enter.NewEdge(Component.Leave, Value, Priority);
  Result := Component;
end;

procedure TNFA.Alternative(const Component, Alt: TNFAComponent; const Priority: Integer);
begin
  Component.Enter.NewEpsilonEdge(Alt.Enter, Priority);
  Alt.Leave.NewEpsilonEdge(Component.Leave);
end;

procedure TNFA.AssignStateIDs;
var I: Integer;
begin
  for I := 0 to Count - 1 do
    Self[I].FID := I;
end;

constructor TNFA.Create(const RE: String);
var
  P: PChar;

  function Peek: Char; inline;
  begin
    Result := P^;
  end;

  procedure Consume; inline;
  begin
    P += 1;
  end;

  procedure ParserError(Msg: String);
  var N: Integer;
  begin
    N := P - PChar(RE);
    raise Exception.Create(Format('%.Create: "%s^%s" - %s',
      [ClassName, Copy(RE, 1, N), Copy(RE, N + 1, Length(RE) - N), Msg]));
  end;

  procedure Expression(out Component: TNFAComponent);

    function Accept(const C: Char): Boolean;
    begin
      Result := Peek = C;
      if Result then
        Consume; // C
    end;

    function Accept(const Chars: TCharSet): Char;
    begin
      Result := Peek;
      if Result in Chars then
        Consume;
    end;

    function Alternative: TNFAComponent;

      function Term(out Component: TNFAComponent): Boolean;

        function One: Char;

          function NonNull: Char;
          begin
            Result := Accept(ALL_CHARS);
            if Result = #0 then
              ParserError('invalid #0 char');
          end;

          function Escaped: Char;

            function X: Integer;
            begin
              if Peek in ['0'..'9', 'a'..'f', 'A'..'F'] then begin
                Result := Hex2Dec(Peek);
                Consume;
              end else
                ParserError('expected hex digit');
            end;

          // function Escaped: Char;
          begin
            Result := NonNull;
            case Result of
              'a': Result := #$07; // allert
              'b': Result := #$08; // backspace
              'f': Result := #$0c; // form feed
              'n': Result := #$0a; // newline
              'r': Result := #$0d; // carriage return
              't': Result := #$09; // horizontal tab
              'v': Result := #$0b; // vertical tab
              'x': Result := Char((X shl 4) or X);
            end;
          end;

        // function One: Char;
        begin
          if Accept('\') then
            Exit(Escaped);
          Result := NonNull;
        end;

        function CharSetComponent(const Chars: TCharSet): TNFAComponent;
        var C: Char;
        begin
          Result := NewComponent;
          for C in Chars do
            Self.Alternative(Result, Ord(C));
        end;

        function BracketExpression: TNFAComponent;
        var
          C: Char;
          Chars: TCharSet = [];
          Invert: Boolean = False;
        begin
          Invert := Accept('^');
          repeat // ']' is a legal first POSIX bracket expr item
            C := One;
            if Accept('-') then
              Chars += [C..One]
            else
              Chars += [C];
          until Accept(']');
          if Invert then
            Chars := NON_NULL_CHARS - Chars;
          Result := CharSetComponent(Chars);
        end;

      // function Term(out Component: TNFAComponent): Boolean;
      begin
        case Accept(['.', '[', '(']) of
          '.': Component := CharSetComponent(DOT_CHARS); //todo:sevDot+implementation in FullMatch
          '[': Component := BracketExpression;
          '(':
            begin
              Expression(Component);
              if not Accept(')') then
                ParserError('expected ")"');
            end;
          #0, '|', ')': Exit(False);
        else
          Component := NewComponent(Ord(One));
        end;
        case Accept(['+', '*', '?']) of
          '+': Component := OneOrMore(Component, Accept('?'));
          '*': Component := ZeroOrMore(Component, Accept('?'));
          '?': Component := ZeroOrOne(Component, Accept('?'));
        end;
        Result := True;
      end;

    // function Alternative: TNFAComponent;
    var
      Component: TNFAComponent;
      Last: TState = nil;
      Edge: TheNFAEdge;
    begin
      while Term(Component) do begin
        if Last <> nil then begin
          for Edge in Component.Enter do
            Last.Add(Edge);
          Remove(Component.Enter);
          Component.Enter.Kill;
        end else
          Result.Enter := Component.Enter;
        Last := Component.Leave;
      end;
      if Last = nil then
        ParserError('expected Term');
      Result.Leave := Last;
    end;

  // procedure Expression(out Component: TNFAComponent);
  begin
    Component := NewComponent;
    repeat
      Self.Alternative(Component, Alternative);
    until not Accept('|');
  end;

// constructor TNFA.Create(const RE: String);
var
  Component: TNFAComponent;
  State: TState;
begin
  inherited Create;
  if RE <> '' then begin
    P := PChar(RE);
    Expression(Component);
    if (P^ <> #0) or (P - PChar(RE) <> Length(RE)) then
      ParserError('syntax error');
  end else
    Component := NewComponent;
  FStartState := Component.Enter;
  FAcceptState := Component.Leave;
  FDotStarStartState := NewState;
  State := NewState;
  DotStarStartState.NewEdge(State, Ord(sevDot));
  State.NewEpsilonEdge(DotStarStartState);
  State.NewEpsilonEdge(TState(StartState));
  AssignStateIDs;
end;

function TNFA.NewComponent(const Value: Integer; const Priority: Integer): TNFAComponent;
begin
  Result := NewComponent();
  Result.Enter.NewEdge(Result.Leave, Value, Priority);
end;

function TNFA.NewComponent: TNFAComponent;
begin
  Result.Enter := NewState;
  Result.Leave := NewState;
end;

function TNFA.NewComponent(const Component: TNFAComponent): TNFAComponent;
begin
  Result := NewComponent();
  Result.Enter.NewEpsilonEdge(Component.Enter);
  Component.Leave.NewEpsilonEdge(Result.Leave);
end;

function TNFA.NewState: TState;
begin
  Result := TState(Push(TState.Create));
end;

function TNFA.OneOrMore(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
begin
  Component.Leave.NewEpsilonEdge(Component.Enter, Ord(NonGreedy));
  Result := Component;
  Result.Enter := NewState;
  Result.Enter.NewEpsilonEdge(Component.Enter);
end;

function TNFA.ZeroOrMore(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
begin
  Component.Leave.NewEpsilonEdge(Component.Enter, Ord(NonGreedy));
  Component.Enter.NewEpsilonEdge(Component.Leave, -Ord(NonGreedy));
  Result := Component;
  Result.Enter := NewState;
  Result.Enter.NewEpsilonEdge(Component.Enter);
end;

function TNFA.ZeroOrOne(const Component: TNFAComponent; const NonGreedy: Boolean): TNFAComponent;
begin
  Component.Enter.NewEpsilonEdge(Component.Leave, -Ord(NonGreedy));
  Result := Component;
end;

function TNFA.FullMatch(const S: String): Boolean;
var
  SrcVM, DestVM, Tmp: TSparseSet;
  P: PChar;
  C, I, J: Integer;
  State: TState;
  Edge: TEdge;
begin
  SrcVM := TSparseSet.Create(Count);
  DestVM := TSparseSet.Create(Count);
  try
    P := PChar(S);
    TState(StartState).Closure(SrcVM);
    repeat
      C := Ord(P^);
      Inc(P);
      if C = 0 then
        Exit(SrcVM.Has(AcceptState.ID));
      DestVM.Clear;
      for I := 0 to SrcVM.Count - 1 do begin
        State := TState(Self[SrcVM[I]]);
        for J := 0 to State.Count - 1 do begin
          Edge := TEdge(State[J]);
          if Edge.Value = C then
            TState(Edge.Target).Closure(DestVM);
        end;
      end;
      Tmp := SrcVM; SrcVM := DestVM; DestVM := Tmp; // SrcVM <-> DestVM
    until SrcVM.Count = 0;
    Result := False;
  finally
    SrcVM.Free;
    DestVM.Free;
  end;
end;

function TNFA.PartialMatch(const S: String): Boolean;
var
  SrcVM, DestVM, Tmp: TSparseSet;
  P: PChar;
  C, I, J: Integer;
  AcceptStateID: Cardinal;
  State: TState;
  Edge: TEdge;
begin
  AcceptStateID := AcceptState.ID;
  SrcVM := TSparseSet.Create(Count);
  DestVM := TSparseSet.Create(Count);
  try
    P := PChar(S);
    if TState(DotStarStartState).Closure(SrcVM, AcceptStateID) then
      Exit(True);
    repeat
      C := Ord(P^);
      Inc(P);
      if C = 0 then
        Exit(SrcVM.Has(AcceptState.ID));
      DestVM.Clear;
      for I := 0 to SrcVM.Count - 1 do begin
        State := TState(Self[SrcVM[I]]);
        for J := 0 to State.Count - 1 do begin
          Edge := TEdge(State[J]);
          if (Edge.Value = C) or ((Edge.Value = Ord(sevDot)) and (Char(C) in DOT_CHARS)) then
            if TState(Edge.Target).Closure(DestVM, AcceptStateID) then
              Exit(True);
        end;
      end;
      Tmp := SrcVM; SrcVM := DestVM; DestVM := Tmp; // SrcVM <-> DestVM
    until SrcVM.Count = 0;
    Result := False;
  finally
    SrcVM.Free;
    DestVM.Free;
  end;
end;

end.

